home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
archiver
/
extar10.zip
/
EXTAR.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-02-26
|
10KB
|
305 lines
Program extar;
{ Extract from TAR file, correcting names to be acceptable for MS-DOS }
{ No checking performed. }
{ FreeWare by TapirSoft Gisbert W.Selke, Feb 1990 }
{$A+,B-,D+,E+,F-,I-,L+,N-,O-,R-,S+,V- }
{$M 16384,0,16384 }
Uses Dos;
Const progname = 'ExTAR';
version = '1.0';
copyright = 'FreeWare by TapirSoft Gisbert W.Selke, Feb 1990';
secsize = 512;
hdrlen = secsize;
secsperblock = 120;
bufsize = secsize * secsperblock;
CR = #13;
Type buf = Array [0..Pred(bufsize)] Of byte;
Var tar, outf : File;
tarname, outname : string;
buffer : buf;
dt : DateTime;
i : byte;
iread, ibuf, nbufs, nrest : word;
nsecs, memberlen, datestamp : longint;
finish : boolean;
Function ReadKey : char;
{ don't need CRT unit for this! }
Inline(
$B4/$08/ { Mov ah, $08 }
$CD/$21); { Int $21 }
Procedure abort(msg : string; ierr : byte);
{ display an error message and die with error code }
Begin { abort }
If IOResult <> 0 Then;
If msg <> '' Then writeln(progname,': ',msg);
Halt(ierr);
End; { abort }
Procedure usage;
{ give hints on usage and die }
Begin { usage }
writeln('A simple programme to extract all members from a TAR file');
writeln('Usage: ',progname,' <tarfilename>');
abort('',1);
End; { usage }
Procedure crackutime(datestamp : longint; Var dt : DateTime);
{ extracts date and time from Unix time stamp, assuming TZ = GMT + 8 }
Const monlen : Array [1..12] Of byte =
(31,28,31,30,31,30,31,31,30,31,30,31);
Begin { crackutime }
With dt Do
Begin
datestamp := datestamp - 8*3600;
sec := datestamp Mod 60;
datestamp := datestamp Div 60;
min := datestamp Mod 60;
datestamp := datestamp Div 60;
hour:= datestamp Mod 24;
datestamp := datestamp Div 24;
year := 1970;
While datestamp > 0 Do
Begin
Inc(year);
If (year Mod 4) = 0 Then day := 366
Else day := 365;
datestamp := datestamp - day;
End;
Dec(year);
day := datestamp + day + 1;
month := 1;
While day > monlen[month] Do
Begin
day := day - monlen[month];
If (month = 2) And ((year Mod 4) = 0) Then Dec(day);
Inc(month);
End;
End;
End; { crackutime }
Procedure openfile(Var outname : string);
{ make a name acceptable for DOS and open the file for output }
Const badletter : Set Of char = ['.','+',' ',':','<','>','|'];
yesset : Set Of char = ['Y','J','1'];
noset : Set Of char = ['N','0'];
Var i : byte;
ch : char;
temp, drive, dir, name, ext : string;
ok : boolean;
Procedure makedirs(Var dir1 : string; dir2 : string);
{ make a directory recursively, if necessary }
Var i : byte;
dire, temp : string;
sr : SearchRec;
Begin { makedirs }
If dir2 = '' Then Exit;
i := Pos('\',dir2);
temp := Copy(dir2,1,Pred(i));
Delete(dir2,1,i);
If temp[1] = '.' Then Delete(temp,1,1);
i := Pos('.',temp);
If i > 0 Then
Begin
dire := Copy(temp,Succ(i),255);
Delete(temp,i,255);
End
Else dire := '';
If Length(temp) > 8 Then
Begin
dire := Copy(temp,9,255);
Delete(temp,9,255);
End;
If Length(dire) > 3 Then Delete(dire,4,255);
If Pos('.',dire) > 0 Then Delete(dire,Pos('.',dire),255);
dir1 := dir1 + temp + '.' + dire;
FindFirst(dir1,directory,sr);
If DosError <> 0 Then
Begin
MkDir(dir1);
If IOResult <> 0 Then abort('Error making directory '+dir1,2);
End;
dir1 := dir1 + '\';
makedirs(dir1,dir2);
End; { makedirs }
Procedure filesplit(path : string; Var drive, dir, name, ext : string);
{ splits path spec into component parts. like Borland FSplit, but }
{ more liberal. }
Var k : byte;
Begin { filesplit }
drive := '';
dir := '';
name := '';
ext := '';
If (Length(path) >= 2) And (path[2] = ':') Then
Begin
drive := Copy(path,1,2);
Delete(path,1,2);
End;
k := Pos('\',path);
While k > 0 Do
Begin
dir := dir + Copy(path,1,k);
Delete(path,1,k);
k := Pos('\',path);
End;
name := path;
If name[1] = '.' Then Delete(name,1,1);
k := Pos('.',name);
If k > 0 Then
Begin
ext := Copy(name,k,255);
Delete(name,k,255);
End;
End; { filesplit }
Begin { openfile }
temp := outname;
ok := True;
For i := Length(temp) DownTo 1 Do
Begin
If temp[i] = '.' Then
Begin
If Not ok Then temp[i] := '_';
ok := False;
End
Else
Begin
If temp[i] = '/' Then temp[i] := '\';
If temp[i] = '\' Then ok := True;
If temp[i] In badletter Then temp[i] := '_';
temp[i] := UpCase(temp[i]);
End;
End;
ok := False;
filesplit(temp,drive,dir,name,ext);
temp := '';
makedirs(temp,dir);
dir := temp;
If ext = '' Then ext := '.';
If Length(name) > 8 Then
Begin
If Length(ext) = 1 Then ext := '.' + Copy(name,9,3);
Delete(name,9,255);
End;
If name = '' Then
Begin
name := Copy(ext,2,255);
ext := '';
End;
If Length(ext) > 4 Then Delete(ext,5,255);
Repeat
Assign(outf,dir+name+ext);
Reset(outf,1);
If IOResult <> 0 Then ok := True
Else
Begin
Close(outf);
write(dir+name+ext,' already exists. Overwrite? (y/n) ');
Repeat
ch := UpCase(ReadKey);
Until ch In yesset + noset;
ok := ch in yesset;
write(CR);
End;
If Not ok Then
Begin
While Length(name) < 8 Do name := name + '0';
i := Length(name);
While (name[i] = '9') And (i > 1) Do
Begin
name[i] := '0';
Dec(i);
End;
If i = 0 Then abort('Cannot fix name '+outname,3);
If Not (name[i] In ['0'..'9']) Then name[i] := '0'
Else name[i] := Succ(name[i]);
End;
Until ok;
temp := dir + name + ext;
write('Original name: ',outname,', DOS name ',temp);
outname := temp;
Rewrite(outf,1);
IF IOResult <> 0 Then abort('Cannot output to file '+outname+'??',4);
End; { openfile }
Begin { main }
writeln(progname,' ',version,' - extract files from a TAR');
writeln(copyright);
If ParamCount <> 1 Then usage;
tarname := ParamStr(1);
If Pos('.',tarname) = 0 Then tarname := tarname + '.TAR';
Assign(tar,tarname);
i := FileMode;
FileMode := 0;
Reset(tar,1);
FileMode := i;
If IORe